home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / PowerLisp 2.01 FAT Folder.sit / PowerLisp 2.01 FAT Folder / PowerLisp 2.01 ƒ / Library / graphics.lisp < prev    next >
Lisp/Scheme  |  1996-05-17  |  3KB  |  127 lines
  1. ;;;
  2. ;;;        PowerLisp 2.0
  3. ;;;        Copyright ｩ 1996 Roger Corman.  All rights reserved.
  4. ;;;;    PowerLisp graphics routines
  5. ;;;;
  6.  
  7. (defpackage graphics
  8.     (:use :common-lisp)
  9.     (:export 
  10.         open-canvas 
  11.         use-canvas 
  12.         moveto 
  13.         lineto
  14.         setcolor
  15.         pensize
  16.         fillrect
  17.         aafillpoly
  18.         fillpoly
  19.         clear-canvas
  20.         filled-ellipse))
  21.  
  22. (in-package :graphics)
  23. (provide :graphics)
  24.  
  25. (defvar *current-point* nil)
  26. (defvar *current-color* nil)
  27.  
  28. (defun open-canvas (canvas-name &key (width 320) (height 240) (depth 0))
  29.     "Usage: (open-canvas canvas-name :width w :height h)
  30.         Creates a canvas with the requested name."
  31.     (%new-canvas canvas-name width height depth)
  32.     (setq *current-point* nil))
  33.  
  34. (defun use-canvas (canvas-name)
  35.     "Usage: (use-canvas canvas-name)
  36.         Makes the requested canvas the current canvas."
  37.     (setq *current-point* nil)
  38.     (%set-current-canvas canvas-name))
  39.  
  40. (defun moveto (x y)
  41.     "Usage: (moveto x y)
  42.         x and y should be integers and are relative to the upper left
  43.         corner of the canvas." 
  44.     (setq *current-point* (cons x y)))
  45.  
  46. (defun lineto (x y)
  47.     "Usage: (lineto x y)
  48.         x and y should be integers and are relative to the upper left
  49.         corner of the canvas." 
  50.     (unless *current-point*
  51.         (error "No current point"))
  52.     (%line (car *current-point*) (cdr *current-point*) x y)
  53.     (setq *current-point* (cons x y)))
  54.  
  55. (defun setcolor (r g b)
  56.     "Usage: (setcolor red green blue)
  57.         Sets the current canvas color to the requested RGB color.
  58.         Red, green and blue should be between 0.0 and 1.0"
  59.     (let ((red (truncate (* r 65535)))
  60.           (green (truncate (* g 65535)))
  61.           (blue (truncate (* b 65535))))
  62.         (%rgbforecolor red green blue)
  63.         (setq *current-color* (list red green blue)))) 
  64.  
  65. (defun pensize (size)
  66.     "Usage: (pensize size)
  67.         The current canvas pen size is set to the requested dimension.
  68.         size should be an integer." 
  69.     (%pensize size size))
  70.  
  71. (defun fillrect (x1 y1 x2 y2)
  72.     "Usage: (fillrect x1 y1 x2 y2)
  73.         A filled rectangle as drawn on the current canvas, using
  74.         the current color." 
  75.     (%fill-polygon `((,x1 . ,y1) (,x2 . ,y1) (,x2 . ,y2) (,x1 . ,y2))))
  76.  
  77. (defun fillpoly (&rest points)
  78.     "Usage: (fillpoly points)
  79.         A filled polygon as drawn on the current canvas, using
  80.         the current color.
  81.         The points list is a list of cons pairs where each cons contains
  82.         two integers (x and y)." 
  83.     (%fill-polygon points))
  84.  
  85. (defun aafillpoly (&rest points)
  86.     "Usage: (aafillpoly points)
  87.         A filled anti-aliased polygon as drawn on the current canvas, using
  88.         the current color.
  89.         The points list is a list of cons pairs where each cons contains
  90.         two integers (x and y)." 
  91.     (%aarender (list points)))
  92.  
  93. (defun clear-canvas () 
  94.     "Usage: (clear-canvas)
  95.         The current canvas is erased."
  96.     (%erase-canvas))
  97.  
  98. (defun filled-ellipse (x1 y1 x2 y2)
  99.     "Usage: (filled-ellipse x1 y1 x2 y2)
  100.         A filled anti-aliased ellipse is drawn on the current canvas
  101.         in the current color."
  102.     (%aaellipse `((,x1 . ,y1) (,x2 . ,y2))))
  103.  
  104. ;;;;    Import all these symbols into Common Lisp package
  105. (in-package :powerlisp)
  106.  
  107. (use-package :graphics)
  108.  
  109.  
  110.  
  111.  
  112.  
  113.  
  114.  
  115.  
  116.  
  117.  
  118.  
  119.  
  120.  
  121.  
  122.  
  123.  
  124.  
  125.  
  126.  
  127.